home *** CD-ROM | disk | FTP | other *** search
/ SPACE 2 / SPACE - Library 2 - Volume 1.iso / program / 17 / examples / hdwr.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1988-07-13  |  8.5 KB  |  318 lines
  1. ; -*-Lisp-*-
  2. ;
  3. ; Jwahar R. Bammi
  4. ; A simple description of hardware objects using xlisp
  5. ; Mix and match instances of the objects to create your
  6. ; organization.
  7. ; Needs:
  8. ; - busses and connection and the Design
  9. ;   Class that will have the connections as instance vars.
  10. ; - Print method for each object, that will display
  11. ;   the instance variables in an human readable form.
  12. ; Some day I will complete it.
  13. ;
  14. ;
  15. ;
  16. ; utility functions
  17.  
  18.  
  19. ; function to calculate 2^n
  20.  
  21. (defun pow2 (n)
  22.     (pow2x n 1))
  23.  
  24. (defun pow2x (n sum)
  25.        (cond((equal n 0) sum)
  26.         (t (pow2x (- n 1) (* sum 2)))))
  27.  
  28.  
  29. ; hardware objects
  30.  
  31. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  32. ;The class areg
  33.  
  34. (setq areg (Class 'new))
  35.  
  36. ; instance variables
  37.  
  38. (areg 'ivars '(value nbits max_val min_val))
  39.  
  40. ; methods
  41.  
  42. ; initialization method
  43. ; when a new instance is called for the user supplies
  44. ; the parameter nbits, from which the max_val & min_val are derived
  45.  
  46. (areg 'answer 'isnew '(n)
  47.       '((self 'init n)
  48.             self))
  49.  
  50. (areg 'answer 'init '(n)
  51.       '((setq value ())
  52.         (setq nbits n)
  53.         (setq max_val (- (pow2 (- n 1)) 1))
  54.         (setq min_val (- (- 0 max_val) 1))))
  55.  
  56. ; load areg
  57.  
  58. (areg 'answer 'load '(val)
  59.       '((cond ((> val max_val) (princ (list "The max value a "nbits" bit register can hold is "max_val"\n")))
  60.           ((< val min_val) (princ (list "The min value a "nbits" bit register can hold is "min_val"\n")))
  61.           (t (setq value val)))))
  62.  
  63. ; see areg
  64.  
  65. (areg 'answer 'see '()
  66.       '((cond ((null value) (princ "Register does not contain a value\n"))
  67.           (t value))))
  68. ;
  69. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  70.  
  71. ; The class creg ( a register that can be cleared and incremented)
  72. ; subclass of a reg
  73.  
  74. (setq creg (Class 'new areg))
  75.  
  76. ; it inherites all the instance vars & methods of a reg
  77. ; in addition to them it has the following methods
  78.  
  79. (creg 'answer 'isnew '(n)
  80.       '((self 'init n)
  81.     self))
  82.  
  83. (creg 'answer 'init '(n)
  84.       '((setq value ())
  85.     (setq nbits n)
  86.     (setq max_val (- (pow2 n) 1))
  87.     (setq min_val 0)))
  88.  
  89. (creg 'answer 'clr '()
  90.       '((setq value 0)))
  91.  
  92. (creg 'answer 'inc '()
  93.       '((cond ((null value) (princ "Register does not contain a value\n"))
  94.           (t (setq value (% (+ value 1) (+ max_val 1)))))))
  95.  
  96. ;
  97. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  98. ;
  99. ; Register bank
  100. ; contains n areg's n_bits each
  101.  
  102. (setq reg_bank (Class 'new))
  103.  
  104. (reg_bank 'ivars '(regs n_regs curr_reg))
  105.  
  106. (reg_bank 'answer 'isnew '(n n_bits)
  107.       '((self 'init n n_bits)
  108.         self))
  109.  
  110. (reg_bank 'answer 'init '(n n_bits)
  111.       '((setq regs ())
  112.         (setq n_regs (- n 1))
  113.         (self 'initx n n_bits)))
  114.  
  115. (reg_bank 'answer 'initx '(n n_bits)
  116.       '((cond ((equal n 0) t)
  117.               (t (list (setq regs (cons (areg 'new n_bits) regs))
  118.           (self 'initx (setq n (- n 1)) n_bits))))))
  119.  
  120. (reg_bank 'answer 'load '(reg val)
  121.       '((cond((> reg n_regs) (princ (list "Only "(+ 1 n_regs)" registers instantiated\n")))
  122.          (t (setq curr_reg (nth (+ reg 1) regs))
  123.             (curr_reg 'load val)))))
  124.  
  125. (reg_bank 'answer 'see '(reg)
  126.       '((cond((> reg n_regs) (princ (list "Only "(+ 1 n_regs)" registers instantiated\n")))
  127.          (t (setq curr_reg (nth (+ reg 1) regs))
  128.             (curr_reg 'see)))))
  129. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  130. ; The Class alu
  131.  
  132. ;alu - an n bit alu
  133.  
  134. (setq alu (Class 'new))
  135.  
  136. ; instance vars
  137.  
  138. (alu 'ivars '(n_bits maxs_val mins_val maxu_val minu_val nf zf vf cf))
  139.  
  140. ; methods
  141.  
  142. (alu 'answer 'isnew '(n)
  143.      '((self 'init n)
  144.        self))
  145.  
  146. (alu 'answer 'init '(n)
  147.      '((setq n_bits n)
  148.        (setq maxu_val (- (pow2 n) 1))
  149.        (setq maxs_val (- (pow2 (- n 1)) 1))
  150.        (setq mins_val (- (- 0 maxs_val) 1))
  151.        (setq minu_val 0)
  152.        (setq nf 0)
  153.        (setq zf 0)
  154.        (setq vf 0)
  155.        (setq cf 0)))
  156.  
  157. (alu 'answer 'check_arith '(a b)
  158.      '((cond ((and (self 'arith_range a) (self 'arith_range b)) t)
  159.          (t ()))))
  160.  
  161. (alu 'answer 'check_logic '(a b)
  162.      '((cond ((and (self 'logic_range a) (self 'logic_range b)) t)
  163.          (t ()))))
  164.  
  165. (alu 'answer 'arith_range '(a)
  166.      '((cond ((< a mins_val) (princ (list "Operand out of Range "a"\n")))
  167.          ((> a maxs_val) (princ (list "Operand out of range "a"\n")))
  168.              (t t))))
  169.  
  170. (alu 'answer 'logic_range '(a)
  171.      '((cond ((< (abs a) minu_val) (princ (list "Operand out of Range "a"\n")))
  172.              (t t))))
  173.  
  174. (alu 'answer 'set_flags '(a b r)
  175.      '((if (equal 0 r) ((setq zf 1)))
  176.        (if (< r 0) ((setq nf 1)))
  177.        (if (or (and (and (< a 0) (< 0 b)) (>= r 0))
  178.           (and (and (>= a 0) (>= b 0)) (< r 0))) ((setq vf 1)))
  179.        (if (or (or (and (< a 0) (< b 0)) (and (< a 0) (>= r 0)))
  180.           (and (>= r 0) (< b 0))) ((setq cf 1)))))
  181.        
  182. (alu 'answer '+ '(a b &aux result)
  183.      '((cond ((null (self 'check_arith a b)) ())
  184.         (t (self 'clear_flags)
  185.            (setq result (+ a b))
  186.            (if (> result maxs_val) ((setq result (+ (- (% result maxs_val) 1) mins_val))))
  187.            (if (< result mins_val) ((setq result (+ (% result mins_val) (+ maxs_val 1)))))
  188.            (self 'set_flags a b result)
  189.            result))))
  190.  
  191. (alu 'answer '& '(a b &aux result)
  192.      '((cond ((null (self 'check_logic a b)) ())
  193.         (t (self 'clear_flags)
  194.            (setq result (bit-and a b))
  195.            (self 'set_flags a b result)
  196.            result))))
  197.  
  198. (alu 'answer '| '(a b &aux result)
  199.      '((cond ((null (self 'check_logic a b)) ())
  200.         (t (self 'clear_flags)
  201.            (setq result (bit-ior a b))
  202.            (self 'set_flags a b result)
  203.            result))))
  204.  
  205. (alu 'answer '~ '(a  &aux result)
  206.      '((cond ((null (self 'check_logic a 0)) ())
  207.         (t (self 'clear_flags)
  208.            (setq result (bit-not a))
  209.            (self 'set_flags a 0 result)
  210.            result))))           
  211.  
  212. (alu 'answer '- '(a b)
  213.      '((self '+ a (- 0 b))))
  214.  
  215. (alu 'answer 'passa '(a)
  216.      '(a))
  217.  
  218. (alu 'answer 'zero '()
  219.      '(0))
  220.  
  221. (alu 'answer 'com '(a)
  222.      '((self '- 0 a)))
  223.  
  224. (alu 'answer 'status '()
  225.      '((princ (list "NF "nf"\n"))
  226.        (princ (list "ZF "zf"\n"))
  227.        (princ (list "CF "cf"\n"))
  228.        (princ (list "VF "vf"\n"))))
  229.  
  230. (alu 'answer 'clear_flags '()
  231.      '((setq nf 0)
  232.        (setq zf 0)
  233.        (setq cf 0)
  234.        (setq vf 0)))
  235.  
  236. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  237. ;
  238. ; The class Memory
  239. ;
  240.  
  241. (setq memory (Class 'new))
  242.  
  243. (memory 'ivars '(nabits ndbits maxu_val maxs_val mins_val max_addr undef memry))
  244.  
  245. (memory 'answer 'isnew '(addr_bits data_bits)
  246.      '((self 'init addr_bits data_bits)
  247.        self))
  248.  
  249. (memory 'answer 'init '(addr_bits data_bits)
  250.      '((setq nabits addr_bits)
  251.        (setq ndbits data_bits)
  252.        (setq maxu_val (- (pow2 data_bits) 1))
  253.        (setq max_addr (- (pow2 addr_bits) 1))
  254.        (setq maxs_val (- (pow2 (- data_bits 1)) 1))
  255.        (setq mins_val (- 0 (pow2 (- data_bits 1))))
  256.        (setq undef (+ maxu_val 1))
  257.        (setq memry (array 'new max_addr undef))))
  258.  
  259.  
  260. (memory 'answer 'load '(loc val)
  261.      '((cond ((> (abs loc) max_addr) (princ (list "Address "loc" out of range\n")))
  262.          ((< val 0) (princ (list "Cant store "val" in "ndbits" bits\n")))
  263.          ((> val maxu_val) (princ (list "Cant store "val" in "ndbits" bits\n")))
  264.          (t (memry 'load loc val)))))
  265.  
  266. (memory 'answer 'write '(loc val)
  267.      '((cond ((> (abs loc) max_addr) (princ (list "Address "loc" out of range\n")))
  268.          ((> val maxs_val) (princ (list "Cant store "val" in "ndbits" bits\n")))
  269.          ((< val mins_val) (princ (list "Cant store "val" in "ndbits" bits\n")))
  270.          (t (memry 'load loc val)))))
  271.  
  272.  
  273. (memory 'answer 'read '(loc &aux val)
  274.      '((cond ((> (abs loc) max_addr) (princ (list "Address "loc" out of range\n")))
  275.          (t (setq val (memry 'see loc))
  276.         (cond ((equal undef val) (princ (list "Address "loc" read before write\n")))
  277.               (t val))))))
  278.  
  279.  
  280. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  281. ;
  282. ; The class array
  283.  
  284. (setq array (Class 'new))
  285.  
  286. (array 'ivars '(arry))
  287.  
  288. (array 'answer 'isnew '(n val)
  289.        '((self 'init n val)
  290.      self))
  291.  
  292. (array 'answer 'init '(n val)
  293.     '((cond ((< n 0) t)
  294.           (t (setq arry (cons val arry))
  295.          (self 'init (- n 1) val)))))
  296.  
  297. (array 'answer 'see '(n)
  298.            '((nth (+ n 1) arry)))
  299.  
  300.  
  301. (array 'answer 'load '(n val &aux left right temp)
  302.        '((setq left (self 'left_part n arry temp))
  303.      (setq right (self 'right_part n arry))
  304.      (setq arry (append left (list val)))
  305.      (setq arry (append arry right))
  306.      val))
  307.  
  308. (array 'answer 'left_part '(n ary left)
  309.        '((cond ((equal n 0) (reverse left))
  310.            (t (setq left (cons (car ary) left))
  311.           (self 'left_part (- n 1) (cdr ary) left)))))
  312.  
  313. (array 'answer 'right_part '(n ary &aux right)
  314.        '((cond ((equal n 0) (cdr ary))
  315.            (t (self 'right_part (- n 1) (cdr ary))))))
  316.  
  317. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  318.